home *** CD-ROM | disk | FTP | other *** search
/ Personal Computer World 2007 September / PCWSEP07.iso / Software / Linux / Linux Mint 3.0 Light / LinuxMint-3.0-Light.iso / casper / filesystem.squashfs / usr / share / perl5 / LWP / Simple.pm < prev    next >
Encoding:
Perl POD Document  |  2004-05-21  |  8.7 KB  |  355 lines
  1. package LWP::Simple;
  2.  
  3. # $Id: Simple.pm,v 1.41 2004/05/21 09:11:55 gisle Exp $
  4.  
  5. use strict;
  6. use vars qw($ua %loop_check $FULL_LWP @EXPORT @EXPORT_OK $VERSION);
  7.  
  8. require Exporter;
  9.  
  10. @EXPORT = qw(get head getprint getstore mirror);
  11. @EXPORT_OK = qw($ua);
  12.  
  13. # I really hate this.  I was a bad idea to do it in the first place.
  14. # Wonder how to get rid of it???  (It even makes LWP::Simple 7% slower
  15. # for trivial tests)
  16. use HTTP::Status;
  17. push(@EXPORT, @HTTP::Status::EXPORT);
  18.  
  19. $VERSION = sprintf("%d.%02d", q$Revision: 1.41 $ =~ /(\d+)\.(\d+)/);
  20. $FULL_LWP++ if grep {lc($_) eq "http_proxy"} keys %ENV;
  21.  
  22.  
  23. sub import
  24. {
  25.     my $pkg = shift;
  26.     my $callpkg = caller;
  27.     if (grep $_ eq '$ua', @_) {
  28.     $FULL_LWP++;
  29.     _init_ua();
  30.     }
  31.     Exporter::export($pkg, $callpkg, @_);
  32. }
  33.  
  34.  
  35. sub _init_ua
  36. {
  37.     require LWP;
  38.     require LWP::UserAgent;
  39.     require HTTP::Status;
  40.     require HTTP::Date;
  41.     $ua = new LWP::UserAgent;  # we create a global UserAgent object
  42.     my $ver = $LWP::VERSION = $LWP::VERSION;  # avoid warning
  43.     $ua->agent("LWP::Simple/$LWP::VERSION");
  44.     $ua->env_proxy;
  45. }
  46.  
  47.  
  48. sub get ($)
  49. {
  50.     %loop_check = ();
  51.     goto \&_get;
  52. }
  53.  
  54.  
  55. sub get_old ($)
  56. {
  57.     my($url) = @_;
  58.     _init_ua() unless $ua;
  59.  
  60.     my $request = HTTP::Request->new(GET => $url);
  61.     my $response = $ua->request($request);
  62.  
  63.     return $response->content if $response->is_success;
  64.     return undef;
  65. }
  66.  
  67.  
  68. sub head ($)
  69. {
  70.     my($url) = @_;
  71.     _init_ua() unless $ua;
  72.  
  73.     my $request = HTTP::Request->new(HEAD => $url);
  74.     my $response = $ua->request($request);
  75.  
  76.     if ($response->is_success) {
  77.     return $response unless wantarray;
  78.     return (scalar $response->header('Content-Type'),
  79.         scalar $response->header('Content-Length'),
  80.         HTTP::Date::str2time($response->header('Last-Modified')),
  81.         HTTP::Date::str2time($response->header('Expires')),
  82.         scalar $response->header('Server'),
  83.            );
  84.     }
  85.     return;
  86. }
  87.  
  88.  
  89. sub getprint ($)
  90. {
  91.     my($url) = @_;
  92.     _init_ua() unless $ua;
  93.  
  94.     my $request = HTTP::Request->new(GET => $url);
  95.     local($\) = ""; # ensure standard $OUTPUT_RECORD_SEPARATOR
  96.     my $callback = sub { print $_[0] };
  97.     if ($^O eq "MacOS") {
  98.     $callback = sub { $_[0] =~ s/\015?\012/\n/g; print $_[0] }
  99.     }
  100.     my $response = $ua->request($request, $callback);
  101.     unless ($response->is_success) {
  102.     print STDERR $response->status_line, " <URL:$url>\n";
  103.     }
  104.     $response->code;
  105. }
  106.  
  107.  
  108. sub getstore ($$)
  109. {
  110.     my($url, $file) = @_;
  111.     _init_ua() unless $ua;
  112.  
  113.     my $request = HTTP::Request->new(GET => $url);
  114.     my $response = $ua->request($request, $file);
  115.  
  116.     $response->code;
  117. }
  118.  
  119.  
  120. sub mirror ($$)
  121. {
  122.     my($url, $file) = @_;
  123.     _init_ua() unless $ua;
  124.     my $response = $ua->mirror($url, $file);
  125.     $response->code;
  126. }
  127.  
  128.  
  129. sub _get
  130. {
  131.     my $url = shift;
  132.     my $ret;
  133.     if (!$FULL_LWP && $url =~ m,^http://([^/:\@]+)(?::(\d+))?(/\S*)?$,) {
  134.     my $host = $1;
  135.     my $port = $2 || 80;
  136.     my $path = $3;
  137.     $path = "/" unless defined($path);
  138.     return _trivial_http_get($host, $port, $path);
  139.     }
  140.     else {
  141.         _init_ua() unless $ua;
  142.     if (@_ && $url !~ /^\w+:/) {
  143.         # non-absolute redirect from &_trivial_http_get
  144.         my($host, $port, $path) = @_;
  145.         require URI;
  146.         $url = URI->new_abs($url, "http://$host:$port$path");
  147.     }
  148.     my $request = HTTP::Request->new(GET => $url);
  149.     my $response = $ua->request($request);
  150.     return $response->is_success ? $response->content : undef;
  151.     }
  152. }
  153.  
  154.  
  155. sub _trivial_http_get
  156. {
  157.    my($host, $port, $path) = @_;
  158.    #print "HOST=$host, PORT=$port, PATH=$path\n";
  159.  
  160.    require IO::Socket;
  161.    local($^W) = 0;
  162.    my $sock = IO::Socket::INET->new(PeerAddr => $host,
  163.                                     PeerPort => $port,
  164.                                     Proto    => 'tcp',
  165.                                     Timeout  => 60) || return undef;
  166.    $sock->autoflush;
  167.    my $netloc = $host;
  168.    $netloc .= ":$port" if $port != 80;
  169.    print $sock join("\015\012" =>
  170.                     "GET $path HTTP/1.0",
  171.                     "Host: $netloc",
  172.                     "User-Agent: lwp-trivial/$VERSION",
  173.                     "", "");
  174.  
  175.    my $buf = "";
  176.    my $n;
  177.    1 while $n = sysread($sock, $buf, 8*1024, length($buf));
  178.    return undef unless defined($n);
  179.  
  180.    if ($buf =~ m,^HTTP/\d+\.\d+\s+(\d+)[^\012]*\012,) {
  181.        my $code = $1;
  182.        #print "CODE=$code\n$buf\n";
  183.        if ($code =~ /^30[1237]/ && $buf =~ /\012Location:\s*(\S+)/i) {
  184.            # redirect
  185.            my $url = $1;
  186.            return undef if $loop_check{$url}++;
  187.            return _get($url, $host, $port, $path);
  188.        }
  189.        return undef unless $code =~ /^2/;
  190.        $buf =~ s/.+?\015?\012\015?\012//s;  # zap header
  191.    }
  192.  
  193.    return $buf;
  194. }
  195.  
  196.  
  197. 1;
  198.  
  199. __END__
  200.  
  201. =head1 NAME
  202.  
  203. LWP::Simple - simple procedural interface to LWP
  204.  
  205. =head1 SYNOPSIS
  206.  
  207.  perl -MLWP::Simple -e 'getprint "http://www.sn.no"'
  208.  
  209.  use LWP::Simple;
  210.  $content = get("http://www.sn.no/");
  211.  die "Couldn't get it!" unless defined $content;
  212.  
  213.  if (mirror("http://www.sn.no/", "foo") == RC_NOT_MODIFIED) {
  214.      ...
  215.  }
  216.  
  217.  if (is_success(getprint("http://www.sn.no/"))) {
  218.      ...
  219.  }
  220.  
  221. =head1 DESCRIPTION
  222.  
  223. This module is meant for people who want a simplified view of the
  224. libwww-perl library.  It should also be suitable for one-liners.  If
  225. you need more control or access to the header fields in the requests
  226. sent and responses received, then you should use the full object-oriented
  227. interface provided by the C<LWP::UserAgent> module.
  228.  
  229. The following functions are provided (and exported) by this module:
  230.  
  231. =over 3
  232.  
  233. =item get($url)
  234.  
  235. The get() function will fetch the document identified by the given URL
  236. and return it.  It returns C<undef> if it fails.  The $url argument can
  237. be either a simple string or a reference to a URI object.
  238.  
  239. You will not be able to examine the response code or response headers
  240. (like 'Content-Type') when you are accessing the web using this
  241. function.  If you need that information you should use the full OO
  242. interface (see L<LWP::UserAgent>).
  243.  
  244. =item head($url)
  245.  
  246. Get document headers. Returns the following 5 values if successful:
  247. ($content_type, $document_length, $modified_time, $expires, $server)
  248.  
  249. Returns an empty list if it fails.  In scalar context returns TRUE if
  250. successful.
  251.  
  252. =item getprint($url)
  253.  
  254. Get and print a document identified by a URL. The document is printed
  255. to the selected default filehandle for output (normally STDOUT) as
  256. data is received from the network.  If the request fails, then the
  257. status code and message are printed on STDERR.  The return value is
  258. the HTTP response code.
  259.  
  260. =item getstore($url, $file)
  261.  
  262. Gets a document identified by a URL and stores it in the file. The
  263. return value is the HTTP response code.
  264.  
  265. =item mirror($url, $file)
  266.  
  267. Get and store a document identified by a URL, using
  268. I<If-modified-since>, and checking the I<Content-Length>.  Returns
  269. the HTTP response code.
  270.  
  271. =back
  272.  
  273. This module also exports the HTTP::Status constants and procedures.
  274. You can use them when you check the response code from getprint(),
  275. getstore() or mirror().  The constants are:
  276.  
  277.    RC_CONTINUE
  278.    RC_SWITCHING_PROTOCOLS
  279.    RC_OK
  280.    RC_CREATED
  281.    RC_ACCEPTED
  282.    RC_NON_AUTHORITATIVE_INFORMATION
  283.    RC_NO_CONTENT
  284.    RC_RESET_CONTENT
  285.    RC_PARTIAL_CONTENT
  286.    RC_MULTIPLE_CHOICES
  287.    RC_MOVED_PERMANENTLY
  288.    RC_MOVED_TEMPORARILY
  289.    RC_SEE_OTHER
  290.    RC_NOT_MODIFIED
  291.    RC_USE_PROXY
  292.    RC_BAD_REQUEST
  293.    RC_UNAUTHORIZED
  294.    RC_PAYMENT_REQUIRED
  295.    RC_FORBIDDEN
  296.    RC_NOT_FOUND
  297.    RC_METHOD_NOT_ALLOWED
  298.    RC_NOT_ACCEPTABLE
  299.    RC_PROXY_AUTHENTICATION_REQUIRED
  300.    RC_REQUEST_TIMEOUT
  301.    RC_CONFLICT
  302.    RC_GONE
  303.    RC_LENGTH_REQUIRED
  304.    RC_PRECONDITION_FAILED
  305.    RC_REQUEST_ENTITY_TOO_LARGE
  306.    RC_REQUEST_URI_TOO_LARGE
  307.    RC_UNSUPPORTED_MEDIA_TYPE
  308.    RC_INTERNAL_SERVER_ERROR
  309.    RC_NOT_IMPLEMENTED
  310.    RC_BAD_GATEWAY
  311.    RC_SERVICE_UNAVAILABLE
  312.    RC_GATEWAY_TIMEOUT
  313.    RC_HTTP_VERSION_NOT_SUPPORTED
  314.  
  315. The HTTP::Status classification functions are:
  316.  
  317. =over 3
  318.  
  319. =item is_success($rc)
  320.  
  321. True if response code indicated a successful request.
  322.  
  323. =item is_error($rc)
  324.  
  325. True if response code indicated that an error occurred.
  326.  
  327. =back
  328.  
  329. The module will also export the LWP::UserAgent object as C<$ua> if you
  330. ask for it explicitly.
  331.  
  332. The user agent created by this module will identify itself as
  333. "LWP::Simple/#.##" (where "#.##" is the libwww-perl version number)
  334. and will initialize its proxy defaults from the environment (by
  335. calling $ua->env_proxy).
  336.  
  337. =head1 CAVEAT
  338.  
  339. Note that if you are using both LWP::Simple and the very popular CGI.pm
  340. module, you may be importing a C<head> function from each module,
  341. producing a warning like "Prototype mismatch: sub main::head ($) vs
  342. none". Get around this problem by just not importing LWP::Simple's
  343. C<head> function, like so:
  344.  
  345.         use LWP::Simple qw(!head);
  346.         use CGI qw(:standard);  # then only CGI.pm defines a head()
  347.  
  348. Then if you do need LWP::Simple's C<head> function, you can just call
  349. it as C<LWP::Simple::head($url)>.
  350.  
  351. =head1 SEE ALSO
  352.  
  353. L<LWP>, L<lwpcook>, L<LWP::UserAgent>, L<HTTP::Status>, L<lwp-request>,
  354. L<lwp-mirror>
  355.